home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / Goodies / SYSTEM~1 / SYSCOL~1.CTL < prev    next >
Text File  |  1997-06-09  |  14KB  |  424 lines
  1. VERSION 5.00
  2. Begin VB.UserControl SysColors 
  3.    AutoRedraw      =   -1  'True
  4.    BorderStyle     =   1  'Fixed Single
  5.    ClientHeight    =   1320
  6.    ClientLeft      =   0
  7.    ClientTop       =   0
  8.    ClientWidth     =   2040
  9.    ScaleHeight     =   88
  10.    ScaleMode       =   3  'Pixel
  11.    ScaleWidth      =   136
  12.    ToolboxBitmap   =   "SysColors.ctx":0000
  13.    Begin VB.VScrollBar VScroll1 
  14.       Height          =   855
  15.       LargeChange     =   9
  16.       Left            =   240
  17.       Max             =   18
  18.       TabIndex        =   0
  19.       Top             =   240
  20.       Width           =   255
  21.    End
  22. End
  23. Attribute VB_Name = "SysColors"
  24. Attribute VB_GlobalNameSpace = False
  25. Attribute VB_Creatable = True
  26. Attribute VB_PredeclaredId = False
  27. Attribute VB_Exposed = True
  28. Option Explicit
  29.  
  30. 'System Color Palette 1.0 - (27 Windows 4.0 System colors)
  31. 'Created by Randy Russell - June 1997
  32. 'Created using Microsoft Visual Basic 5.0
  33.  
  34. 'values for clicktype property
  35. Enum ClickTypes
  36.  SingleClick = 1
  37.  DoubleClick = 2
  38. End Enum
  39. 'values for DefaultColor property
  40. Enum SystemColors
  41.   [3DDKShadow] = 0
  42.   [3DFace] = 1
  43.   [3DHighlight] = 2
  44.   [3DLight] = 3
  45.   [3DShadow] = 4
  46.   ActiveBorder = 5
  47.   ActiveTitleBar = 6
  48.   ApplicationWorkspace = 7
  49.   ButtonFace = 8
  50.   ButtonShadow = 9
  51.   ButtonText = 10
  52.   Desktop = 11
  53.   GrayText = 12
  54.   Highlight = 13
  55.   HighlightText = 14
  56.   InactiveBorder = 15
  57.   InactiveCaptionText = 16
  58.   InactiveTitleBar = 17
  59.   InfoBackground = 18
  60.   InfoText = 19
  61.   MenuBar = 20
  62.   MenuText = 21
  63.   ScrollBars = 22
  64.   TitleBarText = 23
  65.   WindowBackground = 24
  66.   WindowFrame = 25
  67.   WindowText = 26
  68. End Enum
  69. 'declare program variables
  70. Dim SysColorNames(26) As String     'array for color names
  71. Dim SysColors(26) As Long           'array for color values
  72. Dim CurTop As Integer               'scroll position
  73. Dim iColor As Integer               'default, cur selected color
  74. Dim CurHighLight As Integer         'currently highlighted color
  75. Dim rFlag As Boolean                'resize recursion flag
  76. 'Property Variables:
  77. Dim MyClickType As ClickTypes       'single or double click
  78. Dim MyBackColor As OLE_COLOR        'palette background color
  79. Dim MyForeColor As OLE_COLOR        'palette text color
  80. Dim SelColor As Long                'user selected color value
  81. Dim SelColorName As String          'user selected color name
  82. Dim MyColor As Integer              'user selected default color
  83. 'Event Declarations:
  84. Public Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
  85. Public Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
  86. Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
  87. Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
  88. Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
  89. Public Event Scroll(Value As Integer) 'MappingInfo=VScroll1,VScroll1,-1,Scroll
  90. 'Default Property Values:
  91. Const m_def_ClickType = DoubleClick     'default is double click
  92. Const m_def_BackColor = vbButtonFace
  93. Const m_def_ForeColor = vbButtonText
  94. Const CellDim = 13                  'size of color boxes
  95. Const OffsetY = 16                  'distance between rows
  96. Const DefColor = 6                  'default color value vbActiveTitlebar
  97.  
  98. Private Sub DrawCell(CellX As Integer, CellY As Integer, CellWidth As Integer, CellHeight As Integer, CellColor As Long)
  99.  'plot 3d square and fill with current color
  100.  UserControl.ForeColor = &H808080
  101.  UserControl.Line (CellX, CellY)-(CellX + CellWidth - 1, CellY)
  102.  UserControl.Line (CellX, CellY)-(CellX, CellY + CellHeight - 1)
  103.  UserControl.ForeColor = vbWhite
  104.  UserControl.Line (CellX, CellY + CellHeight - 1)-(CellX + CellWidth, CellY + CellHeight - 1)
  105.  UserControl.Line (CellX + CellWidth - 1, CellY)-(CellX + CellWidth - 1, CellY + CellHeight)
  106.  UserControl.ForeColor = &HC0C0C0
  107.  If UserControl.ForeColor = CellColor Then UserControl.ForeColor = &HE0E0E0
  108.  UserControl.Line (CellX + 1, CellY + CellHeight - 2)-(CellX + CellWidth - 1, CellY + CellHeight - 2)
  109.  UserControl.Line (CellX + CellWidth - 2, CellY + 1)-(CellX + CellWidth - 2, CellY + CellHeight - 1)
  110.  UserControl.ForeColor = vbBlack
  111.  UserControl.Line (CellX + 1, CellY + 1)-(CellX + 1, CellY + CellHeight - 2)
  112.  UserControl.Line (CellX + 1, CellY + 1)-(CellX + CellWidth - 2, CellY + 1)
  113.  UserControl.ForeColor = CellColor
  114.  UserControl.Line (CellX + 2, CellY + 2)-(CellX + CellWidth - 3, CellY + CellHeight - 3), , BF
  115. End Sub
  116.  
  117. Private Sub UserControl_Initialize()
  118.  'initialize program variables
  119.  GetColorValues
  120.  CurTop = 0
  121.  rFlag = False
  122. End Sub
  123.  
  124. Private Sub DrawSysPal(TopIndex As Integer)
  125. 'declare local variables
  126. Dim i As Integer
  127. Dim j As Integer
  128. Dim px As Integer
  129. Dim py As Integer
  130.  
  131.  'clear palette and validate top row index
  132.  px = 2
  133.  py = 1
  134.  UserControl.Cls
  135.  UserControl.BackColor = MyBackColor
  136.  'set palette size
  137.  rFlag = True
  138.  UserControl.Width = 2315 'optimum so no horz scroll needed
  139.  rFlag = True
  140.  UserControl.Height = 2240 'setup for 9 visible rows spaced 16 apart + borders
  141.  VScroll1.Top = 0
  142.  VScroll1.Left = 132
  143.  VScroll1.Height = 145
  144.  VScroll1.Width = 18
  145.  If TopIndex > 18 Then TopIndex = 18
  146.  If TopIndex < 0 Then TopIndex = 0
  147.  CurTop = TopIndex
  148.  
  149.  'plot the 9 visible rows
  150.  For i = TopIndex To TopIndex + 8
  151.   DrawCell px, py + 1, CellDim, CellDim, SysColors(i)
  152.   If CurHighLight = i Then
  153.    'draw a filled rect for highlight
  154.    UserControl.Line (px + CellDim + 2, py - 1)-(VScroll1.Left - 5, py + OffsetY - 2), vbHighlight, BF
  155.    UserControl.ForeColor = vbHighlightText
  156.   Else
  157.    UserControl.ForeColor = MyForeColor
  158.   End If
  159.   'position and print color name
  160.   UserControl.CurrentX = px + CellDim + 3
  161.   UserControl.CurrentY = py
  162.   UserControl.Print SysColorNames(i)
  163.   'reset position for next row
  164.   py = py + OffsetY
  165.   px = 2
  166.  Next i
  167.  'add 3d line to seperate scrollbar
  168.  i = VScroll1.Left - 2
  169.  UserControl.Line (i, 0)-(i, ScaleHeight), vb3DShadow
  170.  UserControl.Line (i + 1, 0)-(i + 1, ScaleHeight), vb3DHighlight
  171.  UserControl.Refresh
  172. End Sub
  173.  
  174. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  175. Dim icell As Integer
  176. Dim NewColor As Integer
  177.  'if right button clicked then cancel
  178.  If Button = 2 Then
  179.   SelColorName = ""
  180.   'Hide
  181.  Else
  182.   'determine selection
  183.   icell = Int(Y / OffsetY)
  184.   NewColor = CurTop + icell
  185.   'if clicked the same color again then set selection and hide
  186.   If NewColor = iColor And MyClickType = 1 Then
  187.    SelColor = SysColors(NewColor)
  188.    SelColorName = SysColorNames(NewColor)
  189.    'Hide
  190.   Else
  191.   'else reset highlight and repaint
  192.    iColor = NewColor
  193.    CurHighLight = iColor
  194.    DrawSysPal CurTop
  195.    If MyClickType = 1 Then
  196.     SelColor = SysColors(NewColor)
  197.     SelColorName = SysColorNames(NewColor)
  198.    End If
  199.   End If
  200.  End If
  201.  RaiseEvent MouseDown(Button, Shift, X, Y)
  202. End Sub
  203.  
  204. Private Sub UserControl_InitProperties()
  205.  Set Font = Ambient.Font
  206.  UserControl.Enabled = True
  207.  'set current default color
  208.  MyColor = DefColor
  209.  CurHighLight = MyColor
  210.  SelColor = SysColors(MyColor)
  211.  SelColorName = SysColorNames(MyColor)
  212.  MyBackColor = m_def_BackColor
  213.  MyForeColor = m_def_ForeColor
  214.  MyClickType = m_def_ClickType
  215.  'draw palette
  216.  DrawSysPal CurTop
  217. End Sub
  218.  
  219. Private Sub UserControl_Resize()
  220.  If rFlag Then
  221.   rFlag = False
  222.  Else
  223.   DrawSysPal CurTop
  224.  End If
  225. End Sub
  226.  
  227. Private Sub VScroll1_Change()
  228.  'pass current top row value and repaint
  229.  DrawSysPal VScroll1.Value
  230. End Sub
  231.  
  232. Private Sub UserControl_DblClick()
  233.  'set selection and pass event
  234.  SelColor = SysColors(iColor)
  235.  SelColorName = SysColorNames(iColor)
  236.  RaiseEvent DblClick
  237. End Sub
  238.  
  239. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  240. 'MappingInfo=UserControl,UserControl,-1,Enabled
  241. Public Property Get Enabled() As Boolean
  242. Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
  243.     Enabled = UserControl.Enabled
  244. End Property
  245.  
  246. Public Property Let Enabled(ByVal New_Enabled As Boolean)
  247.     UserControl.Enabled() = New_Enabled
  248.     PropertyChanged "Enabled"
  249. End Property
  250.  
  251. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  252. 'MappingInfo=UserControl,UserControl,-1,Font
  253. Public Property Get Font() As Font
  254. Attribute Font.VB_Description = "Returns a Font object."
  255. Attribute Font.VB_UserMemId = -512
  256.     Set Font = UserControl.Font
  257. End Property
  258.  
  259. Public Property Set Font(ByVal New_Font As Font)
  260.     Set UserControl.Font = New_Font
  261.     PropertyChanged "Font"
  262. End Property
  263.  
  264. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  265.     RaiseEvent MouseMove(Button, Shift, X, Y)
  266. End Sub
  267.  
  268. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  269.     RaiseEvent MouseUp(Button, Shift, X, Y)
  270.     RaiseEvent Click
  271. End Sub
  272.  
  273. Private Sub VScroll1_Scroll()
  274.     RaiseEvent Scroll(VScroll1.Value)
  275. End Sub
  276.  
  277. 'Load property values from storage
  278. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  279.  UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
  280.  Set Font = PropBag.ReadProperty("Font", Ambient.Font)
  281.  MyColor = PropBag.ReadProperty("DefaultColor", DefColor)
  282.  MyBackColor = PropBag.ReadProperty("BackColor", m_def_BackColor)
  283.  MyForeColor = PropBag.ReadProperty("ForeColor", m_def_ForeColor)
  284.  MyClickType = PropBag.ReadProperty("ClickType", m_def_ClickType)
  285.  'set current default color
  286.  CurHighLight = MyColor
  287.  SelColor = SysColors(MyColor)
  288.  SelColorName = SysColorNames(MyColor)
  289.  'draw palette
  290.  DrawSysPal CurTop
  291. End Sub
  292.  
  293. 'Write property values to storage
  294. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  295.  Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
  296.  Call PropBag.WriteProperty("Font", Font, Ambient.Font)
  297.  Call PropBag.WriteProperty("DefaultColor", MyColor, DefColor)
  298.  Call PropBag.WriteProperty("BackColor", MyBackColor, m_def_BackColor)
  299.  Call PropBag.WriteProperty("ForeColor", MyForeColor, m_def_ForeColor)
  300.  Call PropBag.WriteProperty("ClickType", MyClickType, m_def_ClickType)
  301. End Sub
  302.  
  303. Public Sub SetColor(ByVal New_ColorName As String)
  304. Dim i As Integer
  305.  iColor = -1
  306.  For i = 0 To 26
  307.   If New_ColorName = SysColorNames(i) Then
  308.    iColor = i
  309.    Exit For
  310.   End If
  311.  Next i
  312.  If iColor = -1 Then iColor = MyColor
  313.  CurHighLight = iColor
  314.  SelColor = SysColors(iColor)
  315.  SelColorName = SysColorNames(iColor)
  316.  'draw palette
  317.  DrawSysPal CurTop
  318. End Sub
  319.  
  320. Public Property Get SelectedColor() As Long
  321.  SelectedColor = SelColor
  322. End Property
  323.  
  324. Public Property Get SelectedColorName() As String
  325. Attribute SelectedColorName.VB_Description = "Returns the selected colors name."
  326.  SelectedColorName = SelColorName
  327. End Property
  328.  
  329. Public Property Get BackColor() As OLE_COLOR
  330.  BackColor = MyBackColor
  331. End Property
  332.  
  333. Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  334.  MyBackColor = New_BackColor
  335.  PropertyChanged "BackColor"
  336. End Property
  337.  
  338. Public Property Get ForeColor() As OLE_COLOR
  339.  ForeColor = MyForeColor
  340. End Property
  341.  
  342. Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
  343.  MyForeColor = New_ForeColor
  344.  PropertyChanged "ForeColor"
  345. End Property
  346.  
  347. Public Property Get ClickType() As ClickTypes
  348. Attribute ClickType.VB_Description = "Specifies single or double click for selection."
  349.  ClickType = MyClickType
  350. End Property
  351.  
  352. Public Property Let ClickType(ByVal New_ClickType As ClickTypes)
  353.  MyClickType = New_ClickType
  354.  PropertyChanged "ClickType"
  355. End Property
  356.  
  357. Public Property Get DefaultColor() As SystemColors
  358.  DefaultColor = MyColor
  359. End Property
  360.  
  361. Public Property Let DefaultColor(ByVal New_Color As SystemColors)
  362.  MyColor = New_Color
  363.  PropertyChanged "DefaultColor"
  364. End Property
  365.  
  366. Private Sub GetColorValues()
  367.   'assign system color names
  368.   SysColorNames(0) = "3DDKShadow"
  369.   SysColorNames(1) = "3DFace"
  370.   SysColorNames(2) = "3DHighlight"
  371.   SysColorNames(3) = "3DLight"
  372.   SysColorNames(4) = "3DShadow"
  373.   SysColorNames(5) = "ActiveBorder"
  374.   SysColorNames(6) = "ActiveTitleBar"
  375.   SysColorNames(7) = "ApplicationWorkspace"
  376.   SysColorNames(8) = "ButtonFace"
  377.   SysColorNames(9) = "ButtonShadow"
  378.   SysColorNames(10) = "ButtonText"
  379.   SysColorNames(11) = "Desktop"
  380.   SysColorNames(12) = "GrayText"
  381.   SysColorNames(13) = "Highlight"
  382.   SysColorNames(14) = "HighlightText"
  383.   SysColorNames(15) = "InactiveBorder"
  384.   SysColorNames(16) = "InactiveCaptionText"
  385.   SysColorNames(17) = "InactiveTitleBar"
  386.   SysColorNames(18) = "InfoBackground"
  387.   SysColorNames(19) = "InfoText"
  388.   SysColorNames(20) = "MenuBar"
  389.   SysColorNames(21) = "MenuText"
  390.   SysColorNames(22) = "ScrollBars"
  391.   SysColorNames(23) = "TitleBarText"
  392.   SysColorNames(24) = "WindowBackground"
  393.   SysColorNames(25) = "WindowFrame"
  394.   SysColorNames(26) = "WindowText"
  395.   'assign system color values
  396.   SysColors(0) = vb3DDKShadow
  397.   SysColors(1) = vb3DFace
  398.   SysColors(2) = vb3DHighlight
  399.   SysColors(3) = vb3DLight
  400.   SysColors(4) = vb3DShadow
  401.   SysColors(5) = vbActiveBorder
  402.   SysColors(6) = vbActiveTitleBar
  403.   SysColors(7) = vbApplicationWorkspace
  404.   SysColors(8) = vbButtonFace
  405.   SysColors(9) = vbButtonShadow
  406.   SysColors(10) = vbButtonText
  407.   SysColors(11) = vbDesktop
  408.   SysColors(12) = vbGrayText
  409.   SysColors(13) = vbHighlight
  410.   SysColors(14) = vbHighlightText
  411.   SysColors(15) = vbInactiveBorder
  412.   SysColors(16) = vbInactiveCaptionText
  413.   SysColors(17) = vbInactiveTitleBar
  414.   SysColors(18) = vbInfoBackground
  415.   SysColors(19) = vbInfoText
  416.   SysColors(20) = vbMenuBar
  417.   SysColors(21) = vbMenuText
  418.   SysColors(22) = vbScrollBars
  419.   SysColors(23) = vbTitleBarText
  420.   SysColors(24) = vbWindowBackground
  421.   SysColors(25) = vbWindowFrame
  422.   SysColors(26) = vbWindowText
  423. End Sub
  424.